home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
kcl.lha
/
cmpnew
/
cmpspecial.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-03
|
5KB
|
132 lines
;;; CMPSPECIAL Miscellaneous special forms.
;;;
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
(in-package 'compiler)
(si:putprop 'quote 'c1quote 'c1special)
(si:putprop 'function 'c1function 'c1special)
(si:putprop 'function 'c2function 'c2)
(si:putprop 'the 'c1the 'c1special)
(si:putprop 'eval-when 'c1eval-when 'c1special)
(si:putprop 'declare 'c1declare 'c1special)
(si:putprop 'compiler-let 'c1compiler-let 'c1special)
(si:putprop 'compiler-let 'c2compiler-let 'c2)
(defun c1quote (args)
(when (endp args) (too-few-args 'quote 1 0))
(unless (endp (cdr args)) (too-many-args 'quote 1 (length args)))
(c1constant-value (car args) t)
)
(defun c1eval-when (args)
(when (endp args) (too-few-args 'eval-when 1 0))
(dolist** (situation (car args) (c1nil))
(case situation
(eval (return-from c1eval-when (c1progn (cdr args))))
((load compile))
(otherwise
(cmperr "The situation ~s is illegal." situation))))
)
(defun c1declare (args)
(cmperr "The declaration ~s was found in a bad place." (cons 'declare args))
)
(defun c1the (args &aux info form type)
(when (or (endp args) (endp (cdr args)))
(too-few-args 'the 2 (length args)))
(unless (endp (cddr args))
(too-many-args 'the 2 (length args)))
(setq form (c1expr (cadr args)))
(setq info (copy-info (cadr form)))
(setq type (type-and (type-filter (car args)) (info-type info)))
(when (null type)
(cmpwarn "Type mismatch was found in ~s." (cons 'the args)))
(setf (info-type info) type)
(list* (car form) info (cddr form))
)
(defun c1compiler-let (args &aux (symbols nil) (values nil))
(when (endp args) (too-few-args 'compiler-let 1 0))
(dolist** (spec (car args))
(cond ((consp spec)
(cmpck (not (and (symbolp (car spec))
(or (endp (cdr spec))
(endp (cddr spec)))))
"The variable binding ~s is illegal." spec)
(push (car spec) symbols)
(push (if (endp (cdr spec)) nil (eval (cadr spec))) values))
((symbolp spec)
(push spec symbols)
(push nil values))
(t (cmperr "The variable binding ~s is illegal." spec))))
(setq symbols (reverse symbols))
(setq values (reverse values))
(setq args (progv symbols values (c1progn (cdr args))))
(list 'compiler-let (cadr args) symbols values args)
)
(defun c2compiler-let (symbols values body)
(progv symbols values (c2expr body)))
(defun c1function (args &aux fd)
(when (endp args) (too-few-args 'function 1 0))
(unless (endp (cdr args)) (too-many-args 'function 1 (length args)))
(let ((fun (car args)))
(cond ((symbolp fun)
(cond ((and (setq fd (c1local-closure fun))
(eq (car fd) 'call-local))
(list 'function *info* fd))
(t (let ((info (make-info
:sp-change
(null (get fun 'no-sp-change)))))
(list 'function info (list 'call-global info fun))
))))
((and (consp fun) (eq (car fun) 'lambda))
(cmpck (endp (cdr fun))
"The lambda expression ~s is illegal." fun)
(let ((*vars* (cons 'cb *vars*))
(*funs* (cons 'cb *funs*))
(*blocks* (cons 'cb *blocks*))
(*tags* (cons 'cb *tags*)))
(setq fun (c1lambda-expr (cdr fun)))
(list 'function (cadr fun) fun)))
(t (cmperr "The function ~s is illegal." fun))))
)
(defun c2function (funob)
(case (car funob)
(call-global
(unwind-exit (list 'symbol-function (add-symbol (caddr funob)))))
(call-local
(if (cadddr funob)
(unwind-exit (list 'ccb-vs (fun-ref-ccb (caddr funob))))
(unwind-exit (list 'vs* (fun-ref (caddr funob))))))
(t
;;; Lambda closure.
(let ((fun (make-fun :name 'closure :cfun (next-cfun))))
(push (list 'closure (if (null *clink*) nil (cons 0 0))
*ccb-vs* fun funob)
*local-funs*)
(push fun *closures*)
(unwind-exit (list 'make-cclosure (fun-cfun fun) *clink*)))
))
)
(si:putprop 'symbol-function 'wt-symbol-function 'wt-loc)
(si:putprop 'make-cclosure 'wt-make-cclosure 'wt-loc)
(defun wt-symbol-function (vv)
(if *safe-compile*
(wt "symbol_function(VV[" vv "])")
(wt "(VV[" vv "]->s.s_gfdef)")))
(defun wt-make-cclosure (cfun clink)
(wt-nl "make_cclosure(LC" cfun ",Cnil,")
(wt-clink clink)
(wt ",Cdata,Cstart,Csize)"))